home *** CD-ROM | disk | FTP | other *** search
/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / ktencode / ktencode.frm (.txt) < prev    next >
Encoding:
Visual Basic Form  |  1995-05-08  |  8.8 KB  |  260 lines
  1. VERSION 2.00
  2. Begin Form Form1 
  3.    BackColor       =   &H00C0C0C0&
  4.    Caption         =   "KTEncode"
  5.    ClientHeight    =   6615
  6.    ClientLeft      =   375
  7.    ClientTop       =   495
  8.    ClientWidth     =   8655
  9.    Height          =   7020
  10.    Left            =   315
  11.    LinkTopic       =   "Form1"
  12.    ScaleHeight     =   6615
  13.    ScaleWidth      =   8655
  14.    Top             =   150
  15.    Width           =   8775
  16.    Begin CommandButton Command2 
  17.       Caption         =   "Decode"
  18.       Height          =   495
  19.       Left            =   5880
  20.       TabIndex        =   4
  21.       Top             =   120
  22.       Width           =   2415
  23.    End
  24.    Begin TextBox Text2 
  25.       Height          =   375
  26.       Left            =   360
  27.       TabIndex        =   2
  28.       Top             =   360
  29.       Width           =   2655
  30.    End
  31.    Begin CommandButton Command1 
  32.       Caption         =   "Encode"
  33.       Height          =   495
  34.       Left            =   3240
  35.       TabIndex        =   1
  36.       Top             =   120
  37.       Width           =   2415
  38.    End
  39.    Begin TextBox Text1 
  40.       FontBold        =   0   'False
  41.       FontItalic      =   0   'False
  42.       FontName        =   "Terminal"
  43.       FontSize        =   9
  44.       FontStrikethru  =   0   'False
  45.       FontUnderline   =   0   'False
  46.       Height          =   5535
  47.       Left            =   240
  48.       MultiLine       =   -1  'True
  49.       TabIndex        =   0
  50.       Top             =   840
  51.       Width           =   8175
  52.    End
  53.    Begin Label Label1 
  54.       BackColor       =   &H00C0C0C0&
  55.       Caption         =   "Password"
  56.       Height          =   255
  57.       Left            =   360
  58.       TabIndex        =   3
  59.       Top             =   120
  60.       Width           =   2295
  61.    End
  62. Sub Command1_Click ()
  63.   'Encode Text1
  64.   text1.Text = KTEncrypt(Text2.Text, text1.Text, 0, Errors$)
  65.   'Errors??
  66.   If Errors$ <> "" Then MsgBox Errors$, 16, "KTEncrypt Error"
  67. End Sub
  68. Sub Command2_Click ()
  69.   'Decode text1
  70.   text1.Text = KTEncrypt(Text2.Text, text1.Text, 1, Errors$)
  71.   'Errors??
  72.   If Errors$ <> "" Then MsgBox Errors$, 16, "KTEncrypt Error"
  73. End Sub
  74. Sub Form_Load ()
  75.   'Line feed
  76.   LF$ = Chr$(13) + Chr$(10)
  77.   'A message
  78.   msg$ = "Hello," + LF$ + LF$ + LF$
  79.   msg$ = msg$ + "This is a demonstration program of the KTEncrpyt Function."
  80.   msg$ = msg$ + "  Any text in this text box will be encrypted based on a"
  81.   msg$ = msg$ + " password entered above.  Type in a password of at least"
  82.   msg$ = msg$ + " one character then press Encode.  You will see a transformed"
  83.   msg$ = msg$ + " text that is impossible to decifer.  Keeping the password"
  84.   msg$ = msg$ + " the same,  press the decode button and see the file restored."
  85.   msg$ = msg$ + " Try it again but before Decoding change the password and see"
  86.   msg$ = msg$ + " what happens.  Either you get a 'INVALID PASSWORD' error or"
  87.   msg$ = msg$ + " you just get a bunch of useless text.  Feel free to use this"
  88.   msg$ = msg$ + " Function as you please.  The only restriction is if you pass"
  89.   msg$ = msg$ + " it on please distribute the orignal unmodified files in a ZIP"
  90.   msg$ = msg$ + " format.  If you find it usefull or have questions or comments"
  91.   msg$ = msg$ + " send them to:" + LF$ + LF$ + LF$
  92.   msg$ = msg$ + "     K & T " + LF$
  93.   msg$ = msg$ + "     Karl D Albrecht" + LF$
  94.   msg$ = msg$ + "     P.O. Box 478" + LF$
  95.   msg$ = msg$ + "     San Lorenzo, CA 94580-0478" + LF$ + LF$ + LF$
  96.   msg$ = msg$ + "or Send E-Mail to America Online -> KARL25  (KARL25@AOL.COM)" + LF$ + LF$ + LF$
  97.   msg$ = msg$ + "Please read the READTHIS.TXT file for programming information "
  98.   text1.Text = msg$
  99. End Sub
  100. 'Programmed by Karl Albrecht (KARL25@AOL.COM)
  101. Function KTEncrypt (ByVal PASSWORD$, ByVal strng$, Flag%, Errors$)
  102.   'Dimension the Adjust array
  103.   ReDim Adjust(4)
  104.   'Set error capture routine
  105.   On Local Error GoTo ErrorHandler
  106.   'Preserve original string
  107.   original$ = strng$
  108.   'Check for errors (Errorcodes are custom)
  109.   'Is there Password??
  110.   If Len(PASSWORD$) = 0 Then Error 31100
  111.   'Is there a strng$ to work with?
  112.   If Len(strng$) = 0 Then Error 31110
  113.   'Check to see if it is an encoded file
  114.   If Right$(strng$, 5) = String$(5, 255) Then
  115.     'if encoding warn!
  116.     If Flag% = 0 Then Error 31120
  117.   Else
  118.     'If decoding warn
  119.     If Flag% <> 0 Then Error 31130
  120.   End If
  121.   'Create a four part encryption code based on password
  122.   'First Adjust code based on length of password
  123.   Adjust(1) = Len(PASSWORD$)
  124.   'If first character ascii code even make adjust negative
  125.   If Asc(Left$(PASSWORD$, 1)) / 2 = Int(Asc(Left$(PASSWORD$, 1)) / 2) Then
  126.     Adjust(1) = Adjust(1) * -1
  127.   End If
  128.   'Second Adjust code based on first and last character ascii codes
  129.   Adjust(2) = Asc(Left$(PASSWORD$, 1)) - Asc(Right$(PASSWORD$, 1))
  130.   'Third code based on average of all ascii codes
  131.   TotalAscii = 0
  132.   For Looper = 1 To Len(PASSWORD$)
  133.     TotalAscii = TotalAscii + Asc(Mid$(PASSWORD$, Looper, 1))
  134.   Next Looper
  135.   Adjust(3) = Int(TotalAscii / Len(PASSWORD$) / 3)
  136.   'Fourth code based on previous three
  137.   Adjust(4) = Adjust(1) + Adjust(2) + Adjust(3)
  138.   'Now check if any Adjust codes are zero
  139.   'If it is zero make it not zero (any number is fine!)
  140.   For Looper = 1 To 4
  141.     If Adjust(Looper) = 0 Then Adjust(Looper) = Looper + Len(PASSWORD$)
  142.   Next Looper
  143.   'Now check if any adjusts are the same
  144.   NotYet% = 1
  145.   Do While NotYet%
  146.     NotYet% = 0
  147.     For Loop1 = 1 To 4
  148.       For Loop2 = 1 To 4
  149.         'Don't compare same items
  150.         If Loop1 <> Loop2 Then
  151.           
  152.           'Check for a match
  153.           If Adjust(Loop1) = Adjust(Loop2) Then
  154.             Adjust(Loop2) = Adjust(Loop2) + Len(PASSWORD$)
  155.             
  156.             'Make sure we didn't make it zero
  157.             If Adjust(Loop2) = 0 Then Adjust(2) = Adjust(Loop2) + Len(PASSWORD$)
  158.             
  159.             NotYet% = 1
  160.           End If
  161.         End If
  162.       Next Loop2
  163.     Next Loop1
  164.   Loop
  165.   'Encode or deocde
  166.   Counts = 0: Looper = 0
  167.   'Loop until scanned though the whole file
  168.   Do While Looper < Len(strng$)
  169.     'Add to Looper
  170.     Looper = Looper + 1
  171.     'Keep Adjust code Counts from 1 to 4
  172.     Counts = Counts + 1
  173.     If Counts = 5 Then Counts = 1
  174.     'Get the character to change
  175.     ToChange = Asc(Mid$(strng$, Looper, 1))
  176.     'ENCODE   Flag%=0
  177.     If Flag% = 0 Then
  178.       
  179.       'If adjustment to high or low then reverse the coding and
  180.       'add in a chr$(255) to mark the change
  181.       If ToChange - Adjust(Counts) < 1 Or ToChange - Adjust(Counts) > 254 Then
  182.         
  183.         Addin$ = Chr$(255) + Chr$(ToChange + Adjust(Counts))
  184.         strng$ = Left$(strng$, Looper - 1) + Addin$ + Mid$(strng$, Looper + 1)
  185.         Looper = Looper + 1
  186.       
  187.       'If adjustment OK then just cahnge the character
  188.       Else
  189.         
  190.         Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  191.       End If
  192.     'DECODE  Flag% <> 0
  193.     Else
  194.       
  195.       'If find a CHR$(255) then remove it and set Flag255% to
  196.       'ensure reverse codes on next pass reverse coding
  197.       If ToChange = 255 Then
  198.         
  199.         strng$ = Left$(strng$, Looper - 1) + Mid$(strng$, Looper + 1)
  200.         Flag255% = 1
  201.         'Since CHR$(255) was removed we need to back up Looper
  202.         'and Counts because characters all shifted to the left
  203.         Looper = Looper - 1
  204.         Counts = Counts - 1
  205.       
  206.       'If not CHR$(255) then decode watching if Flag255% is set
  207.       Else
  208.         If Flag255% = 1 Then
  209.           Mid$(strng$, Looper, 1) = Chr$(ToChange - Adjust(Counts))
  210.           Flag255% = 0
  211.         Else
  212.           Mid$(strng$, Looper, 1) = Chr$(ToChange + Adjust(Counts))
  213.         End If
  214.       End If
  215.     End If
  216.   Loop
  217.   'Set function equal to changed string
  218.   If Flag% = 0 Then
  219.     'Tack on CHR$(255) to end so it can be recognized as encoded
  220.     KTEncrypt = strng$ + String$(5, 255)
  221.   Else
  222.     KTEncrypt = strng$
  223.   End If
  224.   'Make sure Errors$ is cleared
  225.   Errors$ = ""
  226.   Exit Function
  227. ErrorHandler:
  228.   Select Case Err
  229.     'Illegal Function Call --> out of range ASCII code
  230.     Case 5
  231.       Errors$ = "INVALID PASSWORD!"
  232.     'Is there Password??
  233.     Case 31100
  234.       Errors$ = "NO PASSWORD!"
  235.       
  236.     'Is there a strng$ to work with?
  237.     Case 31110
  238.       Errors$ = "NO STRING!"
  239.     'Encoding a encoded file?
  240.     Case 31120
  241.       If UCase$(Errors$) = "FORCE" Then
  242.         Resume Next
  243.       Else
  244.         Errors$ = "FILE ALREADY ENCODED!"
  245.       End If
  246.     'Decoding a non-encoded file?
  247.     Case 31130
  248.       If UCase$(Errors$) = "FORCE" Then
  249.         Resume Next
  250.       Else
  251.         Errors$ = "FILE NOT ENCODED!"
  252.       End If
  253.     'Unanticipated
  254.     Case Else
  255.       Errors$ = Error$(Err)
  256.   End Select
  257.   KTEncrypt = original$
  258.   Exit Function
  259. End Function
  260.